home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / src / lread.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-07  |  58.5 KB  |  2,247 lines
  1. /* Lisp parsing and input streams.
  2.    Copyright (C) 1985-1989, 1992-1994 Free Software Foundation, Inc.
  3.    Copyright (C) 1995 Amdahl Corporation.
  4.    Copyright (C) 1995 Tinker Systems
  5.  
  6. This file is part of XEmacs.
  7.  
  8. XEmacs is free software; you can redistribute it and/or modify it
  9. under the terms of the GNU General Public License as published by the
  10. Free Software Foundation; either version 2, or (at your option) any
  11. later version.
  12.  
  13. XEmacs is distributed in the hope that it will be useful, but WITHOUT
  14. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16. for more details.
  17.  
  18. You should have received a copy of the GNU General Public License
  19. along with XEmacs; see the file COPYING.  If not, write to the Free
  20. Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  21.  
  22. /* Synched up with: Mule 2.0.  Synched with FSF 19.28 only as far as
  23.    Fload_internal (). */
  24.  
  25. /* This file has been Mule-ized. */
  26.  
  27. #include <config.h>
  28. #include "lisp.h"
  29.  
  30. #ifndef standalone
  31. #include "buffer.h"
  32. #include "bytecode.h"
  33. #include "commands.h"
  34. #include "insdel.h"
  35. #include "lstream.h"
  36. #include "paths.h"
  37. #endif
  38.  
  39. #include "sysfile.h"
  40.  
  41. #ifdef LISP_FLOAT_TYPE
  42. #define THIS_FILENAME lread
  43. #include "sysfloat.h"
  44. #endif /* LISP_FLOAT_TYPE */
  45.  
  46. Lisp_Object Qread_char, Qstandard_input;
  47. Lisp_Object Qvariable_documentation;
  48. #define LISP_BACKQUOTES
  49. #ifdef LISP_BACKQUOTES
  50. #include "opaque.h"
  51. static int reading_backquote, reading_old_backquote;
  52. Lisp_Object Qbackquote, Qbacktick, Qcomma, Qcomma_at;
  53. #endif 
  54. Lisp_Object Qvariable_domain;    /* I18N3 */
  55. Lisp_Object Vvalues, Vstandard_input, Vafter_load_alist;
  56. Lisp_Object Qcurrent_load_list;
  57. Lisp_Object Qload;
  58. Lisp_Object Qlocate_file_hash_table;
  59.  
  60. int puke_on_fsf_keys;
  61.  
  62. /* non-zero if inside `load' */
  63. int load_in_progress;
  64.  
  65. /* Whether Fload_internal() should check whether the .el is newer
  66.    when loading .elc */
  67. int load_warn_when_source_newer;
  68. /* Whether Fload_internal() should check whether the .elc doesn't exist */
  69. int load_warn_when_source_only;
  70. /* Whether Fload_internal() should ignore .elc files when no suffix is given */
  71. int load_ignore_elc_files;
  72.  
  73. /* Search path for files to be loaded. */
  74. Lisp_Object Vload_path;
  75.  
  76. /* Search path for files when dumping. */
  77. /* Lisp_Object Vdump_load_path; */
  78.  
  79. /* This is the user-visible association list that maps features to
  80.    lists of defs in their load files. */
  81. Lisp_Object Vload_history;
  82.  
  83. /* This is used to build the load history. */
  84. Lisp_Object Vcurrent_load_list;
  85.  
  86. /* List of descriptors now open for Fload_internal.  */
  87. static Lisp_Object load_descriptor_list;
  88.  
  89. /* A resizing-buffer stream used to temporarily hold data while reading */
  90. static Lisp_Object Vread_buffer_stream;
  91.  
  92.  
  93. static DOESNT_RETURN
  94. syntax_error (CONST char *string)
  95. {
  96.   signal_error (Qinvalid_read_syntax,
  97.         list1 (build_translated_string (string)));
  98. }
  99.  
  100. static Lisp_Object
  101. continuable_syntax_error (CONST char *string)
  102. {
  103.   return Fsignal (Qinvalid_read_syntax,
  104.           list1 (build_translated_string (string)));
  105. }
  106.  
  107.  
  108. /* Handle unreading and rereading of characters. */
  109.  
  110. static Emchar
  111. readchar (Lisp_Object readcharfun)
  112. {
  113.   /* This function can GC */
  114.  
  115.   if (BUFFERP (readcharfun))
  116.     {
  117.       Emchar c;
  118.       struct buffer *b = XBUFFER (readcharfun);
  119.  
  120.       if (!BUFFER_LIVE_P (b))
  121.         error ("Reading from killed buffer");
  122.  
  123.       if (BUF_PT (b) >= BUF_ZV (b))
  124.         return -1;
  125.       c = BUF_FETCH_CHAR (b, BUF_PT (b));
  126.       BUF_SET_PT (b, BUF_PT (b) + 1);
  127.  
  128.       return c;
  129.     }
  130.   else if (LSTREAMP (readcharfun))
  131.     {
  132.       return Lstream_get_emchar (XLSTREAM (readcharfun));
  133.     }
  134.   else if (MARKERP (readcharfun))
  135.     {
  136.       Emchar c;
  137.       Bufpos mpos = marker_position (readcharfun);
  138.       struct buffer *inbuffer = XMARKER (readcharfun)->buffer;
  139.  
  140.       if (mpos >= BUF_ZV (inbuffer))
  141.     return -1;
  142.       c = BUF_FETCH_CHAR (inbuffer, mpos);
  143.       set_marker_position (readcharfun, mpos + 1);
  144.       return c;
  145.     }
  146.   else
  147.     {
  148.       Lisp_Object tem = call0 (readcharfun);
  149.  
  150.       if (NILP (tem))
  151.     return -1;
  152.       return XINT (tem);
  153.     }
  154. }
  155.  
  156. /* Unread the character C in the way appropriate for the stream READCHARFUN.
  157.    If the stream is a user function, call it with the char as argument.  */
  158.  
  159. static void
  160. unreadchar (Lisp_Object readcharfun, Emchar c)
  161. {
  162.   if (c == -1)
  163.     /* Don't back up the pointer if we're unreading the end-of-input mark,
  164.        since readchar didn't advance it when we read it.  */
  165.     ;
  166.   else if (BUFFERP (readcharfun))
  167.     {
  168.       BUF_SET_PT (XBUFFER (readcharfun), BUF_PT (XBUFFER (readcharfun)) - 1);
  169.     }
  170.   else if (LSTREAMP (readcharfun))
  171.     {
  172.       Lstream_unget_emchar (XLSTREAM (readcharfun), c);
  173.     }
  174.   else if (MARKERP (readcharfun))
  175.     set_marker_position (readcharfun, marker_position (readcharfun) - 1);
  176.   else
  177.     call1 (readcharfun, make_number (c));
  178. }
  179.  
  180. static Lisp_Object read0 (Lisp_Object readcharfun);
  181. static Lisp_Object read1 (Lisp_Object readcharfun);
  182. /* flag = 1 means check for ] to terminate rather than ) and .
  183.    flag = -1 means check for starting with defun
  184.     and make structure pure.  */
  185. static Lisp_Object read_list (Lisp_Object readcharfun,
  186.                               Emchar terminator,
  187.                               int allow_dotted_lists);
  188.  
  189. /* get a character from the tty */
  190.  
  191. #ifdef standalone     /* This primitive is normally not defined */
  192.  
  193. #define kludge DEFUN /* to keep this away from make-docfile... */
  194. kludge ("read-char", Fread_char, Sread_char, 0, 0, 0, "") ()
  195. {
  196.   return getchar ();
  197. }
  198. #undef kludge
  199. #endif /* standalone */
  200.  
  201.  
  202.  
  203. static void readevalloop (Lisp_Object readcharfun, 
  204.                           Lisp_Object sourcefile,
  205.                           Lisp_Object (*evalfun) (Lisp_Object),
  206.                           int printflag);
  207.  
  208. static Lisp_Object
  209. load_unwind (Lisp_Object stream)  /* used as unwind-protect function in load */
  210. {
  211.   Lstream_close (XLSTREAM (stream));
  212.   if (--load_in_progress < 0)
  213.     load_in_progress = 0;
  214.   return Qnil;
  215. }
  216.  
  217. static Lisp_Object
  218. load_descriptor_unwind (Lisp_Object oldlist)
  219. {
  220.   load_descriptor_list = oldlist;
  221.   return Qnil;
  222. }
  223.  
  224. /* Close all descriptors in use for Fload_internals.
  225.    This is used when starting a subprocess.  */
  226.  
  227. void
  228. close_load_descs (void)
  229. {
  230.   Lisp_Object tail;
  231.   LIST_LOOP (tail, load_descriptor_list)
  232.     close (XINT (XCAR (tail)));
  233. }
  234.  
  235. #ifdef I18N3
  236. Lisp_Object Vfile_domain;
  237.  
  238. Lisp_Object
  239. restore_file_domain (Lisp_Object val)
  240. {
  241.   Vfile_domain = val;
  242.   return Qnil;
  243. }
  244. #endif /* I18N3 */
  245.  
  246. DEFUN ("load-internal", Fload_internal, Sload_internal, 1, 4, 0,
  247.   "Execute a file of Lisp code named FILE.\n\
  248. First try LIBRARY with `.elc' appended, then try with `.el',\n\
  249.  then try LIBRARY unmodified.\n\
  250. This function searches the directories in `load-path'.\n\
  251. If optional second arg NOERROR is non-nil,\n\
  252.  report no error if LIBRARY doesn't exist.\n\
  253. Print messages at start and end of loading unless\n\
  254.  optional third arg NOMESSAGE is non-nil (ignored in -batch mode).\n\
  255. If optional fourth arg NOSUFFIX is non-nil, don't try adding\n\
  256.  suffixes `.elc' or `.el' to the specified name LIBRARY.\n\
  257. Return t if file exists.")
  258.   (library, no_error, nomessage, nosuffix)
  259.      Lisp_Object library, no_error, nomessage, nosuffix;
  260. {
  261.   /* This function can GC */
  262.   FILE *stream;
  263.   int fd = -1;
  264.   int speccount = specpdl_depth ();
  265.   Lisp_Object newer = Qnil;
  266.   int source_only = 0;
  267.   Lisp_Object handler = Qnil;
  268.   struct gcpro gcpro1, gcpro2;
  269.   GCPRO2 (library, newer);
  270. #ifdef MSDOS
  271.   char *dosmode = "rt";
  272. #endif
  273.  
  274.   CHECK_STRING (library, 0);
  275.   library = Fsubstitute_in_file_name (library);
  276.  
  277.   /* If file name is magic, call the handler.  */
  278.   handler = Ffind_file_name_handler (library, Qload);
  279.   if (!NILP (handler))
  280.     {
  281.       RETURN_UNGCPRO (call5 (handler, Qload, library, no_error, nomessage,
  282.                  nosuffix));
  283.     }
  284.  
  285.   /* Avoid weird lossage with null string as arg,
  286.      since it would try to load a directory as a Lisp file.
  287.      Unix truly sucks */
  288.   if (string_length (XSTRING (library)) > 0)
  289.     {
  290.       Lisp_Object found = Qnil;
  291.       char *foundstr;
  292.       int foundlen;
  293.       struct gcpro gcpro1;
  294.  
  295.       fd = locate_file (Vload_path, library, 
  296.                         ((!NILP (nosuffix)) ? "" :
  297.              load_ignore_elc_files ? ".el:" :
  298.              ".elc:.el:"),
  299.                         &found,
  300.                         -1);
  301.  
  302.       if (fd < 0)
  303.     {
  304.       if (NILP (no_error))
  305.         signal_file_error ("Cannot open load file", library);
  306.       else
  307.         {
  308.           UNGCPRO;
  309.           return Qnil;
  310.         }
  311.     }
  312.  
  313.       GCPRO1 (found);
  314.       foundstr = (char *) alloca (string_length (XSTRING (found)) + 1);
  315.       strcpy (foundstr, (char *) string_data (XSTRING (found)));
  316.       foundlen = strlen (foundstr);
  317.  
  318.       /* The omniscient JWZ thinks this is worthless, but I beg to
  319.      differ. --ben */
  320.       if (load_ignore_elc_files)
  321.     {
  322.       newer = Ffile_name_nondirectory (found);
  323.     }
  324.       else if (load_warn_when_source_newer &&
  325.            !memcmp (".elc", foundstr + foundlen - 4, 4))
  326.     {
  327.       struct stat s1, s2;
  328.       if (! fstat (fd, &s1))    /* can't fail, right? */
  329.         {
  330.           int result;
  331.           /* temporarily hack the 'c' off the end of the filename */
  332.           foundstr[foundlen - 1] = '\0';
  333.           result = stat (foundstr, &s2);
  334.           if (result >= 0 &&
  335.           (unsigned) s1.st_mtime < (unsigned) s2.st_mtime)
  336.               {
  337.         Lisp_Object newer_name = make_string ((Bufbyte *) foundstr,
  338.                               foundlen - 1);
  339.                 struct gcpro gcpro1;
  340.                 GCPRO1 (newer_name);
  341.         newer = Ffile_name_nondirectory (newer_name);
  342.                 UNGCPRO;
  343.               }
  344.           /* put the 'c' back on (kludge-o-rama) */
  345.           foundstr[foundlen - 1] = 'c';
  346.         }
  347.     }
  348.       else if (load_warn_when_source_only &&
  349.            /* `found' ends in ".el" */
  350.            !memcmp (".el", foundstr + foundlen - 3, 3) &&
  351.            /* `library' does not end in ".el" */
  352.            memcmp (".el",
  353.                string_data (XSTRING (library)) +
  354.                string_length (XSTRING (library)) - 3,
  355.                3))
  356.     {
  357.       source_only = 1;
  358.     }
  359.       UNGCPRO;
  360.     }
  361.  
  362. #ifdef MSDOS
  363.   if (!memcmp (".elc", foundstr + foundlen - 4, 4))
  364.     dosmode = "rb";
  365.   close (fd);
  366.   stream = fopen (foundstr, dosmode);
  367. #else
  368.   stream = fdopen (fd, "r");
  369. #endif
  370.   if (stream == 0)
  371.     {
  372.       close (fd);
  373.       error ("Failure to create stdio stream for %s",
  374.          string_data (XSTRING (library)));
  375.     }
  376.  
  377.   if (load_ignore_elc_files)
  378.     {
  379.       if (noninteractive || NILP (nomessage))
  380.     message ("Loading %s...", string_data (XSTRING (newer)));
  381.     }
  382.   else if (!NILP (newer))
  383.     {
  384.       message ("Loading %s...  (file %s is newer)",
  385.            string_data (XSTRING (library)),
  386.            string_data (XSTRING (newer)));
  387.       nomessage = Qnil; /* we printed the first one, so print "done" too */
  388.     }
  389.   else if (source_only)
  390.     {
  391.       message ("Loading %s...  (file %s.elc does not exist)",
  392.            string_data (XSTRING (library)),
  393.            string_data (XSTRING (Ffile_name_nondirectory (library))));
  394.       nomessage = Qnil;
  395.     }
  396.   else if (noninteractive || NILP (nomessage))
  397.     message ("Loading %s...", string_data (XSTRING (library)));
  398.  
  399.   {
  400.     /* Lisp_Object's must be malloc'ed, not stack-allocated */
  401.     Lisp_Object lispstream;
  402.     struct gcpro gcpro1;
  403.  
  404. #ifdef MULE
  405.     /* !!#### Need to make a Mule-encoding stream */
  406. #endif
  407.     lispstream = make_stdio_stream (stream, LSTR_CLOSING);
  408.     /* 64K is used for normal files; 8K should be OK here because Lisp
  409.        files aren't really all that big. */
  410.     Lstream_set_buffering (XLSTREAM (lispstream), LSTREAM_BLOCKN_BUFFERED,
  411.                8192);
  412.     GCPRO1 (lispstream);
  413.  
  414.     record_unwind_protect (load_unwind, lispstream);
  415.     record_unwind_protect (load_descriptor_unwind, load_descriptor_list);
  416.     load_descriptor_list
  417.       = Fcons (make_number (fileno (stream)), load_descriptor_list);
  418. #ifdef I18N3
  419.     record_unwind_protect (restore_file_domain, Vfile_domain);
  420.     Vfile_domain = Qnil; /* set it to nil; a call to #'domain will set it. */
  421. #endif
  422.     load_in_progress++;
  423.     readevalloop (lispstream, library, Feval, 0);
  424.     unbind_to (speccount, Qnil);
  425.  
  426.     UNGCPRO;
  427.   }
  428.  
  429.   {
  430.     Lisp_Object tem;
  431.     /* #### Disgusting kludge */
  432.     /* Run any load-hooks for this file.  */
  433.     tem = Fassoc (library, Vafter_load_alist);
  434.     if (!NILP (tem))
  435.       {
  436.     struct gcpro gcpro1;
  437.  
  438.     GCPRO1 (tem);
  439.     /* Use eval so that errors give a semi-meaningful backtrace.  --Stig */
  440.     tem = Fcons (Qprogn, Fcdr (tem));
  441.     Feval (tem);
  442.     UNGCPRO;
  443.       }
  444.   }
  445.  
  446.   if (noninteractive || !NILP (nomessage))
  447.     ;
  448.   else if (!NILP (newer))
  449.     message ("Loading %s...done  (file %s is newer)",
  450.          string_data (XSTRING (library)),
  451.          string_data (XSTRING (newer)));
  452.   else
  453.     message ("Loading %s...done", string_data (XSTRING (library)));
  454.  
  455.   UNGCPRO;
  456.   return Qt;
  457. }
  458.  
  459.  
  460. DEFUN ("locate-file", Flocate_file, Slocate_file, 2, 4, 0,
  461.   "Search for FILENAME through PATH-LIST, expanded by one of the optional\n\
  462. SUFFIXES (string of suffixes separated by \":\"s), checking for access\n\
  463. MODE (0|1|2|4 = exists|executable|writeable|readable), default readable.\n\
  464. \n\
  465. `locate-file' keeps hash tables of the directories it searches through,\n\
  466. in order to speed things up.  It tries valiantly to not get confused in\n\
  467. the face of a changing and unpredictable environment, but can occasionally\n\
  468. get tripped up.  In this case, you will have to call\n\
  469. `locate-file-clear-hashing' to get it back on track.  See that function\n\
  470. for details.")
  471.   (file, path, suff, mode)
  472.      Lisp_Object file, path, suff, mode;
  473. {
  474.   /* This function can GC */
  475.   Lisp_Object tp;
  476.  
  477.   CHECK_STRING (file, 0);
  478.   if (!NILP (suff))
  479.     {
  480.       CHECK_STRING (suff, 0);
  481.     }
  482.   if (!(NILP (mode) || (INTP (mode) && XINT (mode) >= 0)))
  483.     mode = wrong_type_argument (Qnatnump, mode);
  484.   locate_file (path, file, 
  485.                ((NILP (suff)) ? "" : (char *) (string_data (XSTRING (suff)))),
  486.            &tp, (NILP (mode) ? R_OK : XINT (mode)));
  487.   return tp;
  488. }
  489.  
  490. /* recalculate the hash table for the given string */
  491.  
  492. static Lisp_Object
  493. locate_file_refresh_hashing (Lisp_Object str)
  494. {
  495.   Lisp_Object hash =
  496.     make_directory_hash_table ((char *) string_data (XSTRING (str)));
  497.   Fput (str, Qlocate_file_hash_table, hash);
  498.   return hash;
  499. }
  500.  
  501. /* find the hash table for the given string, recalculating if necessary */
  502.  
  503. static Lisp_Object
  504. locate_file_find_directory_hash_table (Lisp_Object str)
  505. {
  506.   Lisp_Object hash = Fget (str, Qlocate_file_hash_table, Qnil);
  507.   if (NILP (Fhashtablep (hash)))
  508.     return locate_file_refresh_hashing (str);
  509.   return hash;
  510. }
  511.  
  512. /* look for STR in PATH, optionally adding suffixes in SUFFIX */
  513.  
  514. static int
  515. locate_file_in_directory (Lisp_Object path, Lisp_Object str,
  516.               CONST char *suffix, Lisp_Object *storeptr,
  517.               int mode)
  518. {
  519.   /* This function can GC */
  520.   int fd;
  521.   int fn_size = 100;
  522.   char buf[100];
  523.   char *fn = buf;
  524.   int want_size;
  525.   struct stat st;
  526.   Lisp_Object filename = Qnil;
  527.   struct gcpro gcpro1, gcpro2, gcpro3;
  528.   CONST char *nsuffix;
  529.  
  530.   GCPRO3 (path, str, filename);
  531.  
  532.   filename = Fexpand_file_name (str, path);
  533.   if (NILP (filename) || NILP (Ffile_name_absolute_p (filename)))
  534.     /* If there are non-absolute elts in PATH (eg ".") */
  535.     /* Of course, this could conceivably lose if luser sets
  536.        default-directory to be something non-absolute ... */
  537.     {
  538.       if (NILP (filename))
  539.     /* NIL means current dirctory */
  540.     filename = current_buffer->directory;
  541.       else
  542.     filename = Fexpand_file_name (filename,
  543.                       current_buffer->directory);
  544.       if (NILP (Ffile_name_absolute_p (filename)))
  545.     {
  546.       /* Give up on this path element! */
  547.       UNGCPRO;
  548.       return -1;
  549.     }
  550.     }
  551.   /* Calculate maximum size of any filename made from
  552.      this path element/specified file name and any possible suffix.  */
  553.   want_size = strlen (suffix) +
  554.     string_length (XSTRING (filename)) + 1;
  555.   if (fn_size < want_size)
  556.     fn = (char *) alloca (fn_size = 100 + want_size);
  557.   
  558.   nsuffix = suffix;
  559.   
  560.   /* Loop over suffixes.  */
  561.   while (1)
  562.     {
  563.       char *esuffix = (char *) strchr (nsuffix, ':');
  564.       int lsuffix = ((esuffix) ? (esuffix - nsuffix) : strlen (nsuffix));
  565.       
  566.       /* Concatenate path element/specified name with the suffix.  */
  567.       strncpy (fn, (char *) string_data (XSTRING (filename)), 
  568.            string_length (XSTRING (filename)));
  569.       fn[string_length (XSTRING (filename))] = 0;
  570.       if (lsuffix != 0)  /* Bug happens on CCI if lsuffix is 0.  */
  571.     strncat (fn, nsuffix, lsuffix);
  572.       
  573.       /* Ignore file if it's a directory.  */
  574.       if (stat (fn, &st) >= 0
  575.       && (st.st_mode & S_IFMT) != S_IFDIR)
  576.     {
  577.       /* Check that we can access or open it.  */
  578.       if (mode>=0)
  579.         fd = access (fn, mode);
  580.       else
  581.         fd = open (fn, 0, 0);
  582.       
  583.       if (fd >= 0)
  584.         {
  585.           /* We succeeded; return this descriptor and filename.  */
  586.           if (storeptr)
  587.         *storeptr = build_string (fn);
  588.           UNGCPRO;
  589.           
  590.           /* If we actually opened the file, set close-on-exec flag
  591.          on the new descriptor so that subprocesses can't whack
  592.          at it.  */
  593.           if (mode < 0)
  594.         (void) fcntl (fd, F_SETFD, FD_CLOEXEC);
  595.           
  596.           return fd;
  597.         }
  598.     }
  599.       
  600.       /* Advance to next suffix.  */
  601.       if (esuffix == 0)
  602.     break;
  603.       nsuffix += lsuffix + 1;
  604.     }
  605.   
  606.   UNGCPRO;
  607.   return -1;
  608. }
  609.  
  610. /* do the same as locate_file() but don't use any hash tables. */
  611.  
  612. static int
  613. locate_file_without_hash (Lisp_Object path, Lisp_Object str,
  614.               CONST char *suffix, Lisp_Object *storeptr,
  615.               int mode)
  616. {
  617.   /* This function can GC */
  618.   int absolute;
  619.   struct gcpro gcpro1;
  620.  
  621.   /* is this necessary? */
  622.   GCPRO1 (path);
  623.  
  624.   absolute = !NILP (Ffile_name_absolute_p (str));
  625.  
  626.   for (; !NILP (path); path = Fcdr (path))
  627.     {
  628.       int val = locate_file_in_directory (Fcar (path), str, suffix,
  629.                       storeptr, mode);
  630.       if (val >= 0)
  631.     {
  632.       UNGCPRO;
  633.       return val;
  634.     }
  635.       if (absolute) 
  636.         {
  637.           UNGCPRO;
  638.           return -1;
  639.         }
  640.     }
  641.   
  642.   UNGCPRO;
  643.   return -1;
  644. }
  645.  
  646. /* Construct a list of all files to search for. */
  647.  
  648. static Lisp_Object
  649. locate_file_construct_suffixed_files (Lisp_Object str, CONST char *suffix)
  650. {
  651.   int want_size;
  652.   int fn_size = 100;
  653.   char buf[100];
  654.   char *fn = buf;
  655.   CONST char *nsuffix;
  656.   Lisp_Object suffixtab = Qnil;
  657.   
  658.   /* Calculate maximum size of any filename made from
  659.      this path element/specified file name and any possible suffix.  */
  660.   want_size = strlen (suffix) + string_length (XSTRING (str)) + 1;
  661.   if (fn_size < want_size)
  662.     fn = (char *) alloca (fn_size = 100 + want_size);
  663.   
  664.   nsuffix = suffix;
  665.   
  666.   while (1)
  667.     {
  668.       char *esuffix = (char *) strchr (nsuffix, ':');
  669.       int lsuffix = ((esuffix) ? (esuffix - nsuffix) : strlen (nsuffix));
  670.       
  671.       /* Concatenate path element/specified name with the suffix.  */
  672.       strncpy (fn, (char *) string_data (XSTRING (str)), 
  673.            string_length (XSTRING (str)));
  674.       fn[string_length (XSTRING (str))] = 0;
  675.       if (lsuffix != 0)  /* Bug happens on CCI if lsuffix is 0.  */
  676.     strncat (fn, nsuffix, lsuffix);
  677.       
  678.       suffixtab = Fcons (build_string (fn), suffixtab);
  679.       /* Advance to next suffix.  */
  680.       if (esuffix == 0)
  681.     break;
  682.       nsuffix += lsuffix + 1;
  683.     }
  684.   return Fnreverse (suffixtab);
  685. }
  686.  
  687. /* Search for a file whose name is STR, looking in directories
  688.    in the Lisp list PATH, and trying suffixes from SUFFIX.
  689.    SUFFIX is a string containing possible suffixes separated by colons.
  690.    On success, returns a file descriptor.  On failure, returns -1.
  691.  
  692.    MODE nonnegative means don't open the files,
  693.    just look for one for which access(file,MODE) succeeds.  In this case,
  694.    returns 1 on success.
  695.  
  696.    If STOREPTR is nonzero, it points to a slot where the name of
  697.    the file actually found should be stored as a Lisp string.
  698.    Nil is stored there on failure.  */
  699.  
  700. int
  701. locate_file (Lisp_Object path, Lisp_Object str, CONST char *suffix,
  702.          Lisp_Object *storeptr, int mode)
  703. {
  704.   /* This function can GC */
  705.   Lisp_Object suffixtab = Qnil;
  706.   Lisp_Object pathtail;
  707.   int val;
  708.   struct gcpro gcpro1, gcpro2, gcpro3;
  709.  
  710.   if (storeptr)
  711.     *storeptr = Qnil;
  712.  
  713.   /* if this filename has directory components, it's too complicated
  714.      to try and use the hash tables. */
  715.   if (!NILP (Ffile_name_directory (str)))
  716.     return locate_file_without_hash (path, str, suffix, storeptr,
  717.                      mode);
  718.  
  719.   /* Is it really necessary to gcpro path and str?  It shouldn't be
  720.      unless some caller has fucked up. */
  721.   GCPRO3 (path, str, suffixtab);
  722.  
  723.   suffixtab = locate_file_construct_suffixed_files (str, suffix);
  724.  
  725.   for (pathtail = path; !NILP (pathtail); pathtail = Fcdr (pathtail))
  726.     {
  727.       Lisp_Object pathel = Fcar (pathtail);
  728.       Lisp_Object hashtab;
  729.       Lisp_Object tail;
  730.       int found;
  731.  
  732.       /* If this path element is relative, we have to look by hand.
  733.          Can't set string property in a pure string. */
  734.       if (NILP (pathel) || NILP (Ffile_name_absolute_p (pathel)) ||
  735.       purified (pathel))
  736.     {
  737.       val = locate_file_in_directory (pathel, str, suffix, storeptr,
  738.                       mode);
  739.       if (val >= 0)
  740.         {
  741.           UNGCPRO;
  742.           return val;
  743.         }
  744.       continue;
  745.     }
  746.  
  747.       hashtab = locate_file_find_directory_hash_table (pathel);
  748.  
  749.       /* Loop over suffixes.  */
  750.       for (tail = suffixtab, found = 0; !NILP (tail) && !found;
  751.        tail = Fcdr (tail))
  752.     {
  753.       if (!NILP (Fgethash (Fcar (tail), hashtab, Qnil)))
  754.         found = 1;
  755.     }
  756.  
  757.       if (found)
  758.     {
  759.       /* This is a likely candidate.  Look by hand in this directory
  760.          so we don't get thrown off if someone byte-compiles a file. */
  761.       val = locate_file_in_directory (pathel, str, suffix, storeptr,
  762.                       mode);
  763.       if (val >= 0)
  764.         {
  765.           UNGCPRO;
  766.           return val;
  767.         }
  768.  
  769.       /* Hmm ...  the file isn't actually there. (Or possibly it's
  770.          a directory ...)  So refresh our hashing. */
  771.       locate_file_refresh_hashing (pathel);
  772.     }
  773.     }
  774.  
  775.   /* File is probably not there, but check the hard way just in case. */
  776.   val = locate_file_without_hash (path, str, suffix, storeptr,
  777.                   mode);
  778.   if (val >= 0)
  779.     {
  780.       /* Sneaky user added a file without telling us. */
  781.       Flocate_file_clear_hashing (path);
  782.     }
  783.  
  784.   UNGCPRO;
  785.   return val;
  786. }
  787.  
  788. DEFUN ("locate-file-clear-hashing", Flocate_file_clear_hashing,
  789.        Slocate_file_clear_hashing, 1, 1, 0,
  790.   "Clear the hash records for the specified list of directories.\n\
  791. `locate-file' uses a hashing scheme to speed lookup, and will correctly\n\
  792. track the following environmental changes:\n\
  793. \n\
  794. -- changes of any sort to the list of directories to be searched.\n\
  795. -- addition and deletion of non-shadowing files (see below) from the\n\
  796.    directories in the list.\n\
  797. -- byte-compilation of a .el file into a .elc file.\n\
  798. \n\
  799. `locate-file' will primarily get confused if you add a file that shadows\n\
  800. (i.e. has the same name as) another file further down in the directory list.\n\
  801. In this case, you must call `locate-file-clear-hashing'.")
  802.   (path)
  803.      Lisp_Object path;
  804. {
  805.   Lisp_Object pathtail;
  806.  
  807.   for (pathtail = path; !NILP (pathtail); pathtail = Fcdr (pathtail))
  808.     {
  809.       Lisp_Object pathel = Fcar (pathtail);
  810.       if (!purified (pathel))
  811.     Fput (pathel, Qlocate_file_hash_table, Qnil);
  812.     }
  813.   return Qnil;
  814. }
  815.  
  816. #ifdef LOADHIST
  817.  
  818. /* Merge the list we've accumulated of globals from the current input source
  819.    into the load_history variable.  The details depend on whether
  820.    the source has an associated file name or not. */
  821.  
  822. static void
  823. build_load_history (int loading, Lisp_Object source)
  824. {
  825.   Lisp_Object tail, prev, newelt;
  826.   Lisp_Object tem, tem2;
  827.   int foundit;
  828.  
  829.   /* Don't bother recording anything for preloaded files.  */
  830.   if (purify_flag)
  831.     return;
  832.  
  833.   tail = Vload_history;
  834.   prev = Qnil;
  835.   foundit = 0;
  836.   while (!NILP (tail))
  837.     {
  838.       tem = Fcar (tail);
  839.  
  840.       /* Find the feature's previous assoc list... */
  841.       if (!NILP (Fequal (source, Fcar (tem))))
  842.     {
  843.       foundit = 1;
  844.  
  845.       /*  If we're loading, remove it. */
  846.       if (loading)
  847.         {      
  848.           if (NILP (prev))
  849.         Vload_history = Fcdr (tail);
  850.           else
  851.         Fsetcdr (prev, Fcdr (tail));
  852.         }
  853.  
  854.       /*  Otherwise, cons on new symbols that are not already members.  */
  855.       else
  856.         {
  857.           tem2 = Vcurrent_load_list;
  858.  
  859.           while (CONSP (tem2))
  860.         {
  861.           newelt = Fcar (tem2);
  862.  
  863.           if (NILP (Fmemq (newelt, tem)))
  864.             Fsetcar (tail, Fcons (Fcar (tem),
  865.                       Fcons (newelt, Fcdr (tem))));
  866.  
  867.           tem2 = Fcdr (tem2);
  868.           QUIT;
  869.         }
  870.         }
  871.     }
  872.       else
  873.     prev = tail;
  874.       tail = Fcdr (tail);
  875.       QUIT;
  876.     }
  877.  
  878.   /* If we're loading, cons the new assoc onto the front of load-history,
  879.      the most-recently-loaded position.  Also do this if we didn't find
  880.      an existing member for the current source.  */
  881.   if (loading || !foundit)
  882.     Vload_history = Fcons (Fnreverse (Vcurrent_load_list),
  883.                Vload_history);
  884. }
  885.  
  886. #else /* !LOADHIST */
  887. #define build_load_history(x,y)
  888. #endif /* !LOADHIST */
  889.  
  890.  
  891. static void
  892. readevalloop (Lisp_Object readcharfun, 
  893.               Lisp_Object sourcename,
  894.               Lisp_Object (*evalfun) (Lisp_Object),
  895.               int printflag)
  896. {
  897.   /* This function can GC */
  898.   Emchar c;
  899.   Lisp_Object val;
  900.   int speccount = specpdl_depth ();
  901.   struct gcpro gcpro1;
  902.  
  903.   specbind (Qstandard_input, readcharfun);
  904.   specbind (Qcurrent_load_list, Qnil);
  905.  
  906.   GCPRO1 (sourcename);
  907.  
  908.   LOADHIST_ATTACH (sourcename);
  909.  
  910.   while (1)
  911.     {
  912.       QUIT;
  913.       c = readchar (readcharfun);
  914.       if (c == ';')
  915.     {
  916.           /* Skip comment */
  917.       while ((c = readchar (readcharfun)) != '\n' && c != -1)
  918.             QUIT;
  919.       continue;
  920.     }
  921.       if (c < 0)
  922.         break;
  923.       if (c == ' ' || c == '\t' || c == '\n' || c == '\f')
  924.         continue;
  925.  
  926. #if 0 /* defun hack */
  927.       if (purify_flag && c == '(')
  928.     {
  929.       val = read_list (readcharfun, ')', 1, read_pure, 0, 1);
  930.     }
  931.       else
  932.     {
  933.       unreadchar (readcharfun, c);
  934.       val = read0 (readcharfun);
  935.     }
  936. #else /* No "defun hack" -- Emacs 19 uses read-time syntax for bytecodes */
  937.       unreadchar (readcharfun, c);
  938.       val = read0 (readcharfun);
  939. #endif
  940.       val = (*evalfun) (val);
  941.       if (printflag)
  942.     {
  943.       Vvalues = Fcons (val, Vvalues);
  944.       if (EQ (Vstandard_output, Qt))
  945.         Fprin1 (val, Qnil);
  946.       else
  947.         Fprint (val, Qnil);
  948.     }
  949.     }
  950.  
  951.   build_load_history (1,        /* #### This isn't right */
  952.                       sourcename);
  953.   UNGCPRO;
  954.  
  955.   unbind_to (speccount, Qnil);
  956. }
  957.  
  958. #ifndef standalone
  959.  
  960. DEFUN ("eval-buffer", Feval_buffer, Seval_buffer, 1, 2, "bBuffer: ",
  961.   "Execute BUFFER as Lisp code.\n\
  962. Programs can pass argument PRINTFLAG which controls printing of output:\n\
  963. nil means discard it; anything else is stream for print.")
  964.   (bufname, printflag)
  965.      Lisp_Object bufname, printflag;
  966. {
  967.   /* This function can GC */
  968.   int speccount = specpdl_depth ();
  969.   Lisp_Object tem, buf;
  970.  
  971.   buf = Fget_buffer (bufname);
  972.   if (NILP (buf))
  973.     error ("No such buffer.");
  974.  
  975.   if (NILP (printflag))
  976.     tem = Qsymbolp;             /* #### #@[]*&$#*[& SI:NULL-STREAM */
  977.   else
  978.     tem = printflag;
  979.   specbind (Qstandard_output, tem);
  980.   record_unwind_protect (save_excursion_restore, save_excursion_save ());
  981.   BUF_SET_PT (XBUFFER (buf), BUF_BEGV (XBUFFER (buf)));
  982.   readevalloop (buf, XBUFFER (buf)->filename, Feval,
  983.         !NILP (printflag));
  984.  
  985.   return unbind_to (speccount, Qnil);
  986. }
  987.  
  988. DEFUN ("eval-region", Feval_region, Seval_region, 2, 3, "r",
  989.   "Execute the region as Lisp code.\n\
  990. When called from programs, expects two arguments,\n\
  991. giving starting and ending indices in the current buffer\n\
  992. of the text to be executed.\n\
  993. Programs can pass third argument PRINTFLAG which controls output:\n\
  994. nil means discard it; anything else is stream for printing it.\n\
  995. \n\
  996. If there is no error, point does not move.  If there is an error,\n\
  997. point remains at the end of the last character read from the buffer.\n\
  998. Note:  Before evaling the region, this function narrows the buffer to it.\n\
  999. If the code being eval'd should happen to trigger a redisplay you may\n\
  1000. see some text temporarily disappear because of this.")
  1001.   (b, e, printflag)
  1002.      Lisp_Object b, e, printflag;
  1003. {
  1004.   /* This function can GC */
  1005.   int speccount = specpdl_depth ();
  1006.   Lisp_Object tem;
  1007.   Lisp_Object cbuf = Fcurrent_buffer ();
  1008.  
  1009.   if (NILP (printflag))
  1010.     tem = Qsymbolp;             /* #### #@[]*&$#*[& SI:NULL-STREAM */
  1011.   else
  1012.     tem = printflag;
  1013.   specbind (Qstandard_output, tem);
  1014.   if (NILP (printflag))
  1015.     record_unwind_protect (save_excursion_restore, save_excursion_save ());
  1016.   record_unwind_protect (save_restriction_restore, save_restriction_save ());
  1017.   /* This both uses b and checks its type.  */
  1018.   Fgoto_char (b, cbuf);
  1019.   Fnarrow_to_region (make_number (BUF_BEGV (current_buffer)), e, cbuf);
  1020.   readevalloop (cbuf, XBUFFER (cbuf)->filename, Feval,
  1021.         !NILP (printflag));
  1022.   return unbind_to (speccount, Qnil);
  1023. }
  1024.  
  1025. #endif /* standalone */
  1026.  
  1027. DEFUN ("read", Fread, Sread, 0, 1, 0,
  1028.   "Read one Lisp expression as text from STREAM, return as Lisp object.\n\
  1029. If STREAM is nil, use the value of `standard-input' (which see).\n\
  1030. STREAM or the value of `standard-input' may be:\n\
  1031.  a buffer (read from point and advance it)\n\
  1032.  a marker (read from where it points and advance it)\n\
  1033.  a function (call it with no arguments for each character,\n\
  1034.      call it with a char as argument to push a char back)\n\
  1035.  a string (takes text from string, starting at the beginning)\n\
  1036.  t (read text line using minibuffer and use it).")
  1037.   (stream)
  1038.      Lisp_Object stream;
  1039. {
  1040.   if (NILP (stream))
  1041.     stream = Vstandard_input;
  1042.   if (EQ (stream, Qt))
  1043.     stream = Qread_char;
  1044.  
  1045. #ifndef standalone
  1046.   if (EQ (stream, Qread_char))
  1047.     {
  1048.       Lisp_Object val = call1 (Qread_from_minibuffer, 
  1049.                    build_translated_string ("Lisp expression: "));
  1050.       return (Fcar (Fread_from_string (val, Qnil, Qnil)));
  1051.     }
  1052. #endif
  1053.  
  1054.   if (STRINGP (stream))
  1055.     return Fcar (Fread_from_string (stream, Qnil, Qnil));
  1056.  
  1057.   return read0 (stream);
  1058. }
  1059.  
  1060. DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0,
  1061.   "Read one Lisp expression which is represented as text by STRING.\n\
  1062. Returns a cons: (OBJECT-READ . FINAL-STRING-INDEX).\n\
  1063. START and END optionally delimit a substring of STRING from which to read;\n\
  1064.  they default to 0 and (length STRING) respectively.")
  1065.   (string, start, end)
  1066.      Lisp_Object string, start, end;
  1067. {
  1068.   Bytecount startval, endval;
  1069.   Lisp_Object tem;
  1070.   Lisp_Object lispstream = Qnil;
  1071.   struct gcpro gcpro1;
  1072.  
  1073.   GCPRO1 (lispstream);
  1074.   get_string_range (string, start, end, &startval, &endval);
  1075.   lispstream = make_lisp_string_stream (string, startval,
  1076.                     endval - startval);
  1077.   tem = read0 (lispstream);
  1078.   /* Yeah, it's ugly.  Gonna make something of it? */
  1079.   RETURN_UNGCPRO
  1080.     (Fcons (tem, make_number
  1081.         (bytecount_to_charcount
  1082.          (string_data (XSTRING (string)),
  1083.           startval + Lstream_byte_count (XLSTREAM (lispstream))))));
  1084. }
  1085.  
  1086.  
  1087. #ifdef LISP_BACKQUOTES
  1088. static Lisp_Object
  1089. backquote_unwind (Lisp_Object ptr)
  1090. {  /* used as unwind-protect function in read0() */
  1091.   int *counter = (int *)get_opaque_ptr (ptr);
  1092.   if (--*counter < 0)
  1093.     *counter = 0;  
  1094.   return Qnil;
  1095. }
  1096. #endif 
  1097.  
  1098. /* Use this for recursive reads, in contexts where internal tokens are
  1099.    not allowed.  See also read1(). */
  1100. static Lisp_Object
  1101. read0 (Lisp_Object readcharfun)
  1102. {
  1103.   Lisp_Object val;
  1104.  
  1105.   val = read1 (readcharfun);
  1106.   if (CONSP (val) && EQ (XCAR (val), Qunbound))
  1107.     {
  1108.       Emchar c = XINT (XCDR (val));
  1109.       free_cons (XCONS (val));
  1110.       return Fsignal (Qinvalid_read_syntax,
  1111.               list1 (Fchar_to_string (make_number (c))));
  1112.     }
  1113.  
  1114.   return val;
  1115. }
  1116.  
  1117. static Emchar
  1118. read_escape (Lisp_Object readcharfun)
  1119. {
  1120.   /* This function can GC */
  1121.   Emchar c = readchar (readcharfun);
  1122.   switch (c)
  1123.     {
  1124.     case 'a':
  1125.       return '\007';
  1126.     case 'b':
  1127.       return '\b';
  1128.     case 'd':
  1129.       return 0177;
  1130.     case 'e':
  1131.       return 033;
  1132.     case 'f':
  1133.       return '\f';
  1134.     case 'n':
  1135.       return '\n';
  1136.     case 'r':
  1137.       return '\r';
  1138.     case 't':
  1139.       return '\t';
  1140.     case 'v':
  1141.       return '\v';
  1142.     case '\n':
  1143.       return -1;
  1144.  
  1145.     case 'M':
  1146.       c = readchar (readcharfun);
  1147.       if (c != '-')
  1148.     error ("Invalid escape character syntax");
  1149.       c = readchar (readcharfun);
  1150.       if (c == '\\')
  1151.     c = read_escape (readcharfun);
  1152.       return c | 0200;
  1153.  
  1154. #define FSF_KEYS
  1155. #ifdef FSF_KEYS
  1156.  
  1157. #define alt_modifier   (0x040000)
  1158. #define super_modifier (0x080000)
  1159. #define hyper_modifier (0x100000)
  1160. #define shift_modifier (0x200000)
  1161. /* fsf uses a different modifiers for meta and control.  Possibly
  1162.    byte_compiled code will still work fsfmacs, though... --Stig 
  1163.  
  1164.    #define ctl_modifier   (0x400000)
  1165.    #define meta_modifier  (0x800000)    
  1166. */
  1167. #define FSF_LOSSAGE(charvar, mask)                    \
  1168.       if (puke_on_fsf_keys || ((c = readchar (readcharfun)) != '-'))    \
  1169.     error ("Invalid escape character syntax");            \
  1170.       if ((c =  readchar (readcharfun)) == '\\')            \
  1171.     c = read_escape (readcharfun);                    \
  1172.       return c | mask;
  1173.  
  1174.     case 'S':
  1175.       FSF_LOSSAGE (c, shift_modifier);
  1176.     case 'H':
  1177.       FSF_LOSSAGE (c, hyper_modifier);
  1178.     case 'A':
  1179.       FSF_LOSSAGE (c, alt_modifier);
  1180.     case 's':
  1181.       FSF_LOSSAGE (c, super_modifier);
  1182. #undef alt_modifier
  1183. #undef super_modifier
  1184. #undef hyper_modifier
  1185. #undef shift_modifier
  1186. #undef FSF_LOSSAGE
  1187.  
  1188. #endif /* FSF_KEYS */
  1189.  
  1190.     case 'C':
  1191.       c = readchar (readcharfun);
  1192.       if (c != '-')
  1193.     error ("Invalid escape character syntax");
  1194.     case '^':
  1195.       c = readchar (readcharfun);
  1196.       if (c == '\\')
  1197.     c = read_escape (readcharfun);
  1198.       if (c == '?')
  1199.     return 0177;
  1200.       else
  1201.         return (c & (0200 | 037));
  1202.       
  1203.     case '0':
  1204.     case '1':
  1205.     case '2':
  1206.     case '3':
  1207.     case '4':
  1208.     case '5':
  1209.     case '6':
  1210.     case '7':
  1211.       /* An octal escape, as in ANSI C.  */
  1212.       {
  1213.     Emchar i = c - '0';
  1214.     int count = 0;
  1215.     while (++count < 3)
  1216.       {
  1217.         if ((c = readchar (readcharfun)) >= '0' && c <= '7')
  1218.           {
  1219.         i *= 8;
  1220.         i += c - '0';
  1221.           }
  1222.         else
  1223.           {
  1224.         unreadchar (readcharfun, c);
  1225.         break;
  1226.           }
  1227.       }
  1228.     return i;
  1229.       }
  1230.  
  1231.     case 'x':
  1232.       /* A hex escape, as in ANSI C.  */
  1233.       {
  1234.     Emchar i = 0;
  1235.     while (1)
  1236.       {
  1237.         c = readchar (readcharfun);
  1238.         /* Remember, can't use isdigit(), isalpha() etc.
  1239.            on Emchars */
  1240.         if (c >= '0' && c <= '9')
  1241.           {
  1242.         i *= 16;
  1243.         i += c - '0';
  1244.           }
  1245.         else if ((c >= 'a' && c <= 'f')
  1246.              || (c >= 'A' && c <= 'F'))
  1247.           {
  1248.         i *= 16;
  1249.         if (c >= 'a' && c <= 'f')
  1250.           i += c - 'a' + 10;
  1251.         else
  1252.           i += c - 'A' + 10;
  1253.           }
  1254.         else
  1255.           {
  1256.         unreadchar (readcharfun, c);
  1257.         break;
  1258.           }
  1259.       }
  1260.     return i;
  1261.       }
  1262.  
  1263. #ifdef MULE
  1264.       /* #### need some way of reading an extended character with
  1265.      an escape sequence. */
  1266. #endif
  1267.  
  1268.     default:
  1269.       {
  1270.     return c;
  1271.       }
  1272.     }
  1273. }
  1274.  
  1275.  
  1276.  
  1277. /* read symbol-constituent stuff into `Vread_buffer_stream'. */
  1278. static Bytecount
  1279. read_atom_0 (Lisp_Object readcharfun, Emchar firstchar, int *saw_a_backslash)
  1280. {
  1281.   /* This function can GC */
  1282.   Emchar c = ((firstchar) >= 0 ? firstchar : readchar (readcharfun));
  1283.   Lstream_rewind (XLSTREAM (Vread_buffer_stream));
  1284.  
  1285.   *saw_a_backslash = 0;
  1286.  
  1287.   while (c > 040        /* #### - comma should be here as should backquote */
  1288.          && !(c == '\"' || c == '\'' || c == ';'
  1289.               || c == '(' || c == ')'
  1290.               || c == '[' || c == ']' || c == '#'
  1291.               ))
  1292.     {
  1293.       if (c == '\\')
  1294.     {
  1295.       c = readchar (readcharfun);
  1296.       *saw_a_backslash = 1;
  1297.     }
  1298.       Lstream_put_emchar (XLSTREAM (Vread_buffer_stream), c);
  1299.       QUIT;
  1300.       c = readchar (readcharfun);
  1301.     }
  1302.  
  1303.   if (c >= 0)
  1304.     unreadchar (readcharfun, c);
  1305.   /* blasted terminating 0 */
  1306.   Lstream_put_emchar (XLSTREAM (Vread_buffer_stream), 0);
  1307.   Lstream_flush (XLSTREAM (Vread_buffer_stream));
  1308.  
  1309.   return (Lstream_byte_count (XLSTREAM (Vread_buffer_stream)) - 1);
  1310. }
  1311.  
  1312. static Lisp_Object parse_integer (CONST Bufbyte *buf, Bytecount len, int base);
  1313.  
  1314. static Lisp_Object
  1315. read_atom (Lisp_Object readcharfun,
  1316.            Emchar firstchar,
  1317.            int uninterned_symbol)
  1318. {
  1319.   /* This function can GC */
  1320.   int saw_a_backslash;
  1321.   Bytecount len = read_atom_0 (readcharfun, firstchar, &saw_a_backslash);
  1322.   char *read_ptr = (char *)
  1323.     resizing_buffer_stream_ptr (XLSTREAM (Vread_buffer_stream));
  1324.  
  1325.   /* Is it an integer? */
  1326.   if (! (saw_a_backslash || uninterned_symbol))
  1327.     {
  1328.       /* If a token had any backslashes in it, it is disqualified from
  1329.      being an integer or a float.  This means that 123\456 is a
  1330.      symbol, as is \123 (which is the way (intern "123") prints).
  1331.      Also, if token was preceeded by #:, it's always a symbol.
  1332.        */
  1333.       char *p = read_ptr + len;
  1334.       char *p1 = read_ptr;
  1335.  
  1336.       if (*p1 == '+' || *p1 == '-') p1++;
  1337.       if (p1 != p)
  1338.     {
  1339.           int c;
  1340.  
  1341.           while (p1 != p && (c = *p1) >= '0' && c <= '9')
  1342.             p1++;
  1343.           if (p1 == p)
  1344.             {
  1345.               /* It is an integer. */
  1346. #if 0
  1347.           int number = 0;
  1348.               number = atoi (read_ptr);
  1349.           return (make_number (number));
  1350. #else
  1351.               return (parse_integer ((Bufbyte *) read_ptr, len, 10));
  1352. #endif
  1353.         }
  1354.     }
  1355. #ifdef LISP_FLOAT_TYPE
  1356.       if (isfloat_string (read_ptr))
  1357.     return make_float (atof (read_ptr));
  1358. #endif
  1359.     }
  1360.  
  1361.   {
  1362.     Lisp_Object sym;
  1363.     if (uninterned_symbol)
  1364.       sym = (Fmake_symbol ((purify_flag) 
  1365.                ? make_pure_pname ((Bufbyte *) read_ptr, len, 0)
  1366.                : make_string ((Bufbyte *) read_ptr, len)));
  1367.     else
  1368.       {
  1369.     /* intern will purecopy pname if necessary */
  1370.     Lisp_Object name = make_string ((Bufbyte *) read_ptr, len);
  1371.     sym = Fintern (name, Qnil);
  1372.       }
  1373.     if (SYMBOL_IS_KEYWORD (sym))
  1374.       {
  1375.     /* the LISP way is to put keywords in their own package, but we don't
  1376.        have packages, so we do something simpler.  Someday, maybe we'll
  1377.        have packages and then this will be reworked.  --Stig. */
  1378.     XSYMBOL (sym)->value = sym;
  1379.       }
  1380.     return (sym);
  1381.   }
  1382. }
  1383.  
  1384.  
  1385. static Lisp_Object
  1386. parse_integer (CONST Bufbyte *buf, Bytecount len, int base)
  1387. {
  1388.   CONST Bufbyte *lim = buf + len;
  1389.   CONST Bufbyte *p = buf;
  1390.   unsigned LISP_WORD_TYPE num = 0;
  1391.   int negativland = 0;
  1392.  
  1393.   if (*p == '-')
  1394.   {
  1395.     negativland = 1;
  1396.     p++;
  1397.   }
  1398.   else if (*p == '+')
  1399.   {
  1400.     p++;
  1401.   }
  1402.  
  1403.   if (p == lim)
  1404.     goto loser;
  1405.  
  1406.   for (; p < lim; p++)
  1407.   {
  1408.     int c = *p;
  1409.     unsigned LISP_WORD_TYPE onum;
  1410.  
  1411.     if (isdigit (c))
  1412.       c = c - '0';
  1413.     else if (isupper (c))
  1414.       c = c - 'A' + 10;
  1415.     else if (islower (c))
  1416.       c = c - 'a' + 10;
  1417.     else
  1418.       goto loser;
  1419.     
  1420.     if (c < 0 || c >= base)
  1421.       goto loser;
  1422.  
  1423.     onum = num;
  1424.     num = num * base + c;
  1425.     if (num < onum)
  1426.       goto overflow;
  1427.   }
  1428.  
  1429.   {
  1430.     Lisp_Object result = make_number ((negativland) ? -num : num);
  1431.     if (num && ((XINT (result) < 0) != negativland))
  1432.       goto overflow;
  1433.     if (XINT (result) != ((negativland) ? -num : num))
  1434.       goto overflow;
  1435.     return (result);
  1436.   }
  1437.  overflow:
  1438.   return Fsignal (Qinvalid_read_syntax, 
  1439.                   list3 (build_translated_string
  1440.              ("Integer constant overflow in reader"),
  1441.                          make_string (buf, len),
  1442.                          make_number (base)));
  1443.  loser:
  1444.   return Fsignal (Qinvalid_read_syntax, 
  1445.                   list3 (build_translated_string
  1446.              ("Invalid integer constant in reader"),
  1447.                          make_string (buf, len),
  1448.                          make_number (base)));
  1449. }
  1450.  
  1451.  
  1452. static Lisp_Object
  1453. read_integer (Lisp_Object readcharfun, int base)
  1454. {
  1455.   /* This function can GC */
  1456.   int saw_a_backslash;
  1457.   Bytecount len = read_atom_0 (readcharfun, -1, &saw_a_backslash);
  1458.   return (parse_integer
  1459.       (resizing_buffer_stream_ptr (XLSTREAM (Vread_buffer_stream)),
  1460.        ((saw_a_backslash)
  1461.         ? 0 /* make parse_integer signal error */
  1462.         : len),
  1463.        base));
  1464. }
  1465.  
  1466.  
  1467.  
  1468.  
  1469. static Lisp_Object read_bytecode (Lisp_Object readcharfun, int terminator);
  1470. static Lisp_Object read_vector (Lisp_Object readcharfun, int terminator);
  1471.  
  1472. /* Get the next character; filter out whitespace and comments */
  1473.  
  1474. static Emchar
  1475. reader_nextchar (Lisp_Object readcharfun)
  1476. {
  1477.   /* This function can GC */
  1478.   Emchar c;
  1479.  
  1480.  retry:
  1481.   QUIT;
  1482.   c = readchar (readcharfun);
  1483.   if (c < 0)
  1484.     signal_error (Qend_of_file, list1 (readcharfun));
  1485.  
  1486.   switch (c)
  1487.     {
  1488.     default:
  1489.       {
  1490.     /* Ignore whitespace and control characters */
  1491.     if (c <= 040)
  1492.       goto retry;
  1493.     return (c);
  1494.       }
  1495.  
  1496.     case ';':
  1497.       {
  1498.         /* Comment */
  1499.         while ((c = readchar (readcharfun)) >= 0 && c != '\n')
  1500.           QUIT;
  1501.         goto retry;
  1502.       }
  1503.     }
  1504. }
  1505.  
  1506. #if 0
  1507. static Lisp_Object
  1508. list2_pure (int pure, Lisp_Object a, Lisp_Object b)
  1509. {
  1510.   if (pure)
  1511.     return (pure_cons (a, pure_cons (b, Qnil)));
  1512.   else
  1513.     return (list2 (a, b));
  1514. }
  1515. #endif
  1516.  
  1517. /* Read the next Lisp object from the stream READCHARFUN and return it.
  1518.    If the return value is a cons whose car in Qunbound, then read1()
  1519.    encountered a misplaced token (e.g. a right bracket, right paren,
  1520.    or dot followed by a non-number).  To filter this stuff out,
  1521.    use read0(). */
  1522.   
  1523. static Lisp_Object
  1524. read1 (Lisp_Object readcharfun)
  1525. {
  1526.   Emchar c;
  1527.  
  1528. retry:
  1529.   c = reader_nextchar (readcharfun);
  1530.  
  1531.   switch (c)
  1532.     {
  1533.     case '(':
  1534.       {
  1535. #ifdef LISP_BACKQUOTES    /* old backquote compatibility in lisp reader */
  1536.     /* if this is disabled, then other code in eval.c must be enabled */
  1537.     int ch = reader_nextchar (readcharfun);
  1538.     switch (ch)
  1539.       {
  1540.       case '`':
  1541.         {
  1542.           Lisp_Object tem;
  1543.           int speccount = specpdl_depth ();
  1544.           ++reading_old_backquote;
  1545.           record_unwind_protect (backquote_unwind,
  1546.                      make_opaque_ptr (&reading_old_backquote));
  1547.           tem = read0 (readcharfun);
  1548.           unbind_to (speccount, Qnil);
  1549.           ch = reader_nextchar (readcharfun);
  1550.           if (ch != ')')
  1551.         {
  1552.           unreadchar (readcharfun, ch);
  1553.           return Fsignal (Qinvalid_read_syntax,
  1554.                   list1 (build_string
  1555.                      ("Weird old-backquote syntax")));
  1556.         }
  1557.           return list2 (Qbacktick, tem);
  1558.         }
  1559.       case ',':
  1560.         {
  1561.           if (reading_old_backquote)
  1562.         {
  1563.           Lisp_Object tem, comma_type;
  1564.           ch = readchar (readcharfun);
  1565.           if (ch == '@')
  1566.             comma_type = Qcomma_at;
  1567.           else
  1568.             {
  1569.               if (ch >= 0)
  1570.             unreadchar (readcharfun, ch);
  1571.               comma_type = Qcomma;
  1572.             }
  1573.           tem = read0 (readcharfun);
  1574.           ch = reader_nextchar (readcharfun);
  1575.           if (ch != ')')
  1576.             {
  1577.               unreadchar (readcharfun, ch);
  1578.               return Fsignal (Qinvalid_read_syntax,
  1579.                       list1 (build_string
  1580.                          ("Weird old-backquote syntax")));
  1581.             }
  1582.           return list2 (comma_type, tem);
  1583.         }
  1584.           else
  1585.         {
  1586.           unreadchar (readcharfun, ch);
  1587. #if 0
  1588.           return Fsignal (Qinvalid_read_syntax,
  1589.                list1 (build_string ("Comma outside of backquote")));
  1590. #else
  1591.           /* #### - yuck....but this is reverse compatible. */
  1592.           /* mostly this is required by edebug, which does it's own
  1593.              annotated reading.  We need to have an annotated_read
  1594.              function that records (with markers) the buffer
  1595.              positions of the elements that make up lists, then that
  1596.              can be used in edebug and bytecomp and the check above
  1597.              can go back in. --Stig */
  1598.           break;
  1599. #endif
  1600.         }
  1601.         }
  1602.       default:
  1603.         unreadchar (readcharfun, ch);
  1604.       }            /* switch(ch) */
  1605. #endif /* old backquote crap... */
  1606.     return read_list (readcharfun, ')', 1);
  1607.       }
  1608.     case '[':
  1609.       return (read_vector (readcharfun, ']'));
  1610.  
  1611.     case ')':
  1612.     case ']':
  1613.       /* #### - huh? these don't do what they seem... */
  1614.       return (Fcons (Qunbound, make_number (c)));
  1615.     case '.':
  1616.       {
  1617. #ifdef LISP_FLOAT_TYPE
  1618.     /* If a period is followed by a number, then we should read it
  1619.        as a floating point number.  Otherwise, it denotes a dotted
  1620.        pair.
  1621.      */
  1622.     c = readchar (readcharfun);
  1623.     unreadchar (readcharfun, c);
  1624.  
  1625.     /* Can't use isdigit on Emchars */
  1626.     if (c < '0' || c > '9')
  1627.       return (Fcons (Qunbound, make_number ('.')));
  1628.  
  1629.     /* Note that read_atom will loop
  1630.        at least once, assuring that we will not try to UNREAD
  1631.            two characters in a row.
  1632.        (I think this doesn't matter anymore because there should
  1633.        be no more danger in unreading multiple characters) */
  1634.         return (read_atom (readcharfun, '.', 0));
  1635.  
  1636. #else /* ! LISP_FLOAT_TYPE */
  1637.     return (Fcons (Qunbound, make_number ('.')));
  1638. #endif /* ! LISP_FLOAT_TYPE */
  1639.       }
  1640.  
  1641.     case '#':
  1642.       {
  1643.     c = readchar (readcharfun);
  1644.     switch (c)
  1645.       {
  1646.       case '[':
  1647.         {
  1648.           /* "#["-- byte-code constant syntax */
  1649.           return (read_bytecode (readcharfun, ']'
  1650.           /* purecons #[...] syntax */
  1651.           /*, purify_flag */ ));
  1652.         }
  1653.       case ':':
  1654.         {
  1655.           /* "#:"-- quasi-implemented gensym syntax */
  1656.           return (read_atom (readcharfun, -1, 1));
  1657.         }
  1658.       case '\'':
  1659.         {
  1660.           /* #'x => (function x) */
  1661.           return (list2 (Qfunction, read0 (readcharfun)));
  1662.         }
  1663. #if 0
  1664.         /* RMS uses this syntax for fat-strings.
  1665.            If we use it for vectors, then obscure bugs happen.
  1666.          */
  1667.       case '(':
  1668.         {
  1669.           /* "#(" -- Scheme/CL vector syntax */
  1670.           return (read_vector (readcharfun, ')'));
  1671.         }
  1672. #endif
  1673.       case 'o':
  1674.         {
  1675.           /* #o10 => 8 -- octal constant syntax */
  1676.           return (read_integer (readcharfun, 8));
  1677.         }
  1678.       case 'x':
  1679.         {
  1680.           /* #xdead => 57005 -- hex constant syntax */
  1681.           return (read_integer (readcharfun, 16));
  1682.         }
  1683.       case 'b':
  1684.         {
  1685.           /* #b010 => 2 -- binary constant syntax */
  1686.           return (read_integer (readcharfun, 2));
  1687.         }
  1688.  
  1689.       case '<':
  1690.         {
  1691.           unreadchar (readcharfun, c);
  1692.           return Fsignal (Qinvalid_read_syntax,
  1693.             list1 (build_string ("Cannot read unreadable object")));
  1694.         }
  1695.  
  1696.       default:
  1697.         {
  1698.           unreadchar (readcharfun, c);
  1699.           return Fsignal (Qinvalid_read_syntax,
  1700.                   list1 (build_string ("#")));
  1701.         }
  1702.       }
  1703.       }
  1704.  
  1705.     case '\'':
  1706.       {
  1707.     /* Quote */
  1708.     return list2 (Qquote, read0 (readcharfun));
  1709.       }
  1710.  
  1711. #ifdef LISP_BACKQUOTES
  1712.     case '`':
  1713.       {
  1714.     Lisp_Object tem;
  1715.     int speccount = specpdl_depth ();
  1716.     ++reading_backquote;
  1717.     record_unwind_protect (backquote_unwind,
  1718.                    make_opaque_ptr (&reading_backquote));
  1719.     tem = read0 (readcharfun);
  1720.     unbind_to (speccount, Qnil);
  1721.     return list2 (Qbackquote, tem);
  1722.       }
  1723.  
  1724.     case ',':
  1725.       {
  1726.     if (reading_backquote)
  1727.       {
  1728.         Lisp_Object comma_type = Qnil;
  1729.         int ch = readchar (readcharfun);
  1730.  
  1731.         if (ch == '@')
  1732.           comma_type = Qcomma_at;
  1733.         else
  1734.           {
  1735.         if (ch >= 0)
  1736.           unreadchar (readcharfun, ch);
  1737.         comma_type = Qcomma;
  1738.           }
  1739.         return list2 (comma_type, read0 (readcharfun));
  1740.       }
  1741.     else
  1742.       {
  1743.         /* YUCK.  99.999% backwards compatibility.  The Right
  1744.            Thing(tm) is to signal an error here, because it's
  1745.            really invalid read syntax.  Instead, this permits
  1746.            commas to begin symbols (unless they're inside
  1747.            backquotes).  If an error is signalled here in the
  1748.            future, then commas should be invalid read syntax
  1749.            outside of backquotes anywhere they're found (i.e.
  1750.            they must be quoted in symbols) -- Stig */
  1751.         return (read_atom (readcharfun, c, 0));
  1752.       }
  1753.       }
  1754. #endif
  1755.  
  1756.     case '?':
  1757.       {
  1758.     /* Evil GNU Emacs "character" (ie integer) syntax */
  1759.     c = readchar (readcharfun);
  1760.     if (c < 0)
  1761.       return Fsignal (Qend_of_file, list1 (readcharfun));
  1762.  
  1763.     if (c == '\\')
  1764.       c = read_escape (readcharfun);
  1765.     return (make_number (c));
  1766.       }
  1767.  
  1768.     case '\"':
  1769.       {
  1770.     /* String */
  1771. #ifdef I18N3
  1772.     /* #### If the input stream is translating, then the string
  1773.        should be marked as translatable by setting its
  1774.        `string-translatable' property to t.  .el and .elc files
  1775.        normally are translating input streams.  See Fgettext()
  1776.        and print_internal(). */
  1777. #endif
  1778.     int cancel = 0;
  1779.  
  1780.     Lstream_rewind (XLSTREAM (Vread_buffer_stream));
  1781.     while ((c = readchar (readcharfun)) >= 0
  1782.            && c != '\"')
  1783.       {
  1784.         if (c == '\\')
  1785.           c = read_escape (readcharfun);
  1786.         /* c is -1 if \ newline has just been seen */
  1787.         if (c == -1)
  1788.           {
  1789.         if (Lstream_byte_count (XLSTREAM (Vread_buffer_stream)) == 0)
  1790.           cancel = 1;
  1791.           }
  1792.         else
  1793.           Lstream_put_emchar (XLSTREAM (Vread_buffer_stream), c);
  1794.         QUIT;
  1795.       }
  1796.     if (c < 0)
  1797.       return Fsignal (Qend_of_file, list1 (readcharfun));
  1798.  
  1799.     /* If purifying, and string starts with \ newline,
  1800.        return zero instead.  This is for doc strings
  1801.        that we are really going to find in lib-src/DOC.nn.nn  */
  1802.     if (purify_flag && NILP (Vdoc_file_name) && cancel)
  1803.       return (Qzero);
  1804.  
  1805.     Lstream_flush (XLSTREAM (Vread_buffer_stream));
  1806.         return
  1807.       make_string
  1808.         (resizing_buffer_stream_ptr (XLSTREAM (Vread_buffer_stream)),
  1809.          Lstream_byte_count (XLSTREAM (Vread_buffer_stream)));
  1810.       }
  1811.  
  1812.     default:
  1813.       {
  1814.     /* Ignore whitespace and control characters */
  1815.     if (c <= 040)
  1816.       goto retry;
  1817.     return (read_atom (readcharfun, c, 0));
  1818.       }
  1819.     }
  1820. }
  1821.  
  1822.  
  1823.  
  1824. #ifdef LISP_FLOAT_TYPE
  1825.  
  1826. #define LEAD_INT 1
  1827. #define DOT_CHAR 2
  1828. #define TRAIL_INT 4
  1829. #define E_CHAR 8
  1830. #define EXP_INT 16
  1831.  
  1832. int
  1833. isfloat_string (CONST char *cp)
  1834. {
  1835.   int state = 0;
  1836.   CONST Bufbyte *ucp = (Bufbyte *) cp;
  1837.   
  1838.   if (*ucp == '+' || *ucp == '-')
  1839.     ucp++;
  1840.  
  1841.   if (isdigit (*ucp))
  1842.     {
  1843.       state |= LEAD_INT;
  1844.       while (isdigit (*ucp))
  1845.     ucp++;
  1846.     }
  1847.   if (*ucp == '.')
  1848.     {
  1849.       state |= DOT_CHAR;
  1850.       ucp++;
  1851.     }
  1852.   if (isdigit (*ucp))
  1853.     {
  1854.       state |= TRAIL_INT;
  1855.       while (isdigit (*ucp))
  1856.     ucp++;
  1857.     }
  1858.   if (*ucp == 'e' || *ucp == 'E')
  1859.     {
  1860.       state |= E_CHAR;
  1861.       ucp++;
  1862.     }
  1863.   if ((*ucp == '+') || (*ucp == '-'))
  1864.     ucp++;
  1865.  
  1866.   if (isdigit (*ucp))
  1867.     {
  1868.       state |= EXP_INT;
  1869.       while (isdigit (*ucp))
  1870.     ucp++;
  1871.     }
  1872.   return (*ucp == 0
  1873.       && (state == (LEAD_INT|DOT_CHAR|TRAIL_INT)
  1874.           || state == (DOT_CHAR|TRAIL_INT)
  1875.           || state == (LEAD_INT|E_CHAR|EXP_INT)
  1876.           || state == (LEAD_INT|DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)
  1877.           || state == (DOT_CHAR|TRAIL_INT|E_CHAR|EXP_INT)));
  1878. }
  1879. #endif /* LISP_FLOAT_TYPE */
  1880.  
  1881. static void *
  1882. sequence_reader (Lisp_Object readcharfun,
  1883.                  Emchar terminator,
  1884.                  void *state,
  1885.                  void * (*conser) (Lisp_Object readcharfun,
  1886.                                    void *state, Charcount len))
  1887. {
  1888.   Charcount len;
  1889.  
  1890.   for (len = 0; ; len++)
  1891.   {
  1892.     Emchar ch;
  1893.  
  1894.     QUIT;
  1895.     ch = reader_nextchar (readcharfun);
  1896.  
  1897.     if (ch == terminator)
  1898.       return (state);
  1899.     else
  1900.       unreadchar (readcharfun, ch);
  1901.     if (ch == ']')
  1902.       syntax_error ("\"]\" in a list");
  1903.     else if (ch == ')')
  1904.       syntax_error ("\")\" in a vector");
  1905.     state = ((conser) (readcharfun, state, len));
  1906.   }
  1907. }
  1908.  
  1909.  
  1910. struct read_list_state 
  1911.   {
  1912.     Lisp_Object head; Lisp_Object tail;
  1913.     int allow_dotted_lists; 
  1914.     Emchar terminator;
  1915.   };
  1916.  
  1917. static void *
  1918. read_list_conser (Lisp_Object readcharfun, void *state, Charcount len)
  1919. {
  1920.   struct read_list_state *s = state;
  1921.   Lisp_Object elt;
  1922.  
  1923.   elt = read1 (readcharfun);
  1924.   if (CONSP (elt) && EQ (XCAR (elt), Qunbound))
  1925.     {
  1926.       Lisp_Object tem = elt;
  1927.       Emchar ch;
  1928.       
  1929.       elt = XCDR (elt);
  1930.       free_cons (XCONS (tem));
  1931.       tem = Qnil;
  1932.       ch = XINT (elt);
  1933.       if (ch != '.')
  1934.     signal_simple_error ("BUG! Internal reader error", elt);
  1935.       else if (!s->allow_dotted_lists)
  1936.     syntax_error ("\".\" in a vector");
  1937.       else
  1938.     {
  1939.       if (!NILP (s->tail))
  1940.         XCDR (s->tail) = read0 (readcharfun);
  1941.           else
  1942.         s->head = read0 (readcharfun);
  1943.       elt = read1 (readcharfun);
  1944.       if (CONSP (elt) && EQ (XCAR (elt), Qunbound)
  1945.           && XINT (XCDR (elt)) == s->terminator)
  1946.         {
  1947.           free_cons (XCONS (elt));
  1948.           unreadchar (readcharfun, s->terminator);
  1949.           goto done;
  1950.         }
  1951.       syntax_error (". in wrong context");
  1952.     }
  1953.     }
  1954.  
  1955. #if 0
  1956.   if (NILP (tail) && defun_hack && EQ (elt, Qdefun) && !read_pure)
  1957.     {
  1958.       record_unwind_protect (unreadpure, Qzero);
  1959.       read_pure = 1;
  1960.     }
  1961. #endif
  1962.   elt = Fcons (elt, Qnil);
  1963.   if (!NILP (s->tail))
  1964.     XCDR (s->tail) = elt;
  1965.   else
  1966.     s->head = elt;
  1967.   s->tail = elt;
  1968.  done:
  1969.   return (s);
  1970. }
  1971.  
  1972.  
  1973. static Lisp_Object
  1974. read_list (Lisp_Object readcharfun,
  1975.            Emchar terminator,
  1976.            int allow_dotted_lists)
  1977. {
  1978.   struct read_list_state s;
  1979.   struct gcpro gcpro1, gcpro2;
  1980.  
  1981.   s.head = Qnil;
  1982.   s.tail = Qnil;
  1983.   s.allow_dotted_lists = allow_dotted_lists;
  1984.   s.terminator = terminator;
  1985.   GCPRO2 (s.head, s.tail);
  1986.  
  1987.   (void) sequence_reader (readcharfun,
  1988.                           terminator,
  1989.                           &s,
  1990.                           read_list_conser);
  1991.   UNGCPRO;
  1992.   return (s.head);
  1993. }
  1994.  
  1995. static Lisp_Object
  1996. read_vector (Lisp_Object readcharfun,
  1997.              Emchar terminator)
  1998. {
  1999.   Lisp_Object tem;
  2000.   Lisp_Object *p;
  2001.   int len;
  2002.   int i;
  2003.   struct read_list_state s;
  2004.   struct gcpro gcpro1, gcpro2;
  2005.  
  2006.  
  2007.   s.head = Qnil;
  2008.   s.tail = Qnil;
  2009.   s.allow_dotted_lists = 0;
  2010.   GCPRO2 (s.head, s.tail);
  2011.   
  2012.   (void) sequence_reader (readcharfun,
  2013.                           terminator,
  2014.                           &s,
  2015.                           read_list_conser);
  2016.   UNGCPRO;
  2017.   tem = s.head;
  2018.   len = XINT (Flength (tem));
  2019.  
  2020.   s.head = make_vector (len, Qnil);
  2021.  
  2022.   for (i = 0, p = &(vector_data (XVECTOR (s.head))[0]);
  2023.        i < len;
  2024.        i++, p++)
  2025.   {
  2026.     struct Lisp_Cons *otem = XCONS (tem);
  2027.     tem = Fcar (tem);
  2028.     *p = tem;
  2029.     tem = otem->cdr;
  2030.     free_cons (otem);
  2031.   }
  2032.   return (s.head);
  2033. }
  2034.  
  2035. static Lisp_Object
  2036. read_bytecode (Lisp_Object readcharfun, Emchar terminator)
  2037. {
  2038.   /* Accept compiled functions at read-time so that we don't 
  2039.      have to build them at load-time. */
  2040.   Lisp_Object stuff;
  2041.   Lisp_Object make_byte_code_args[COMPILED_DOMAIN + 1];
  2042.   struct gcpro gcpro1;
  2043.   int len;
  2044.   int iii;
  2045.  
  2046.   stuff = read_list (readcharfun, terminator, 0);
  2047.   len = XINT (Flength (stuff));
  2048.   if (len < COMPILED_STACK_DEPTH + 1 || len > COMPILED_DOMAIN + 1)
  2049.     return
  2050.       continuable_syntax_error ("#[...] used with wrong number of elements");
  2051.  
  2052.   for (iii = 0; CONSP (stuff); iii++)
  2053.   {
  2054.     struct Lisp_Cons *victim = XCONS (stuff);
  2055.     make_byte_code_args[iii] = Fcar (stuff);
  2056.     stuff = Fcdr (stuff);
  2057.     free_cons (victim);
  2058.   }
  2059.   GCPRO1 (make_byte_code_args[0]);
  2060.   gcpro1.nvars = len;
  2061.  
  2062.   /* make-byte-code looks at purify_flag, which should have the same
  2063.    *  value as our "read-pure" argument */
  2064.   RETURN_UNGCPRO (Fmake_byte_code (len, make_byte_code_args));
  2065. }
  2066.  
  2067.  
  2068.  
  2069. void
  2070. init_lread (void)
  2071. {
  2072. #ifdef PATH_LOADSEARCH
  2073.   CONST char *normal = PATH_LOADSEARCH;
  2074.  
  2075. /* Don't print this warning.  If the hardcoded paths don't exist, then
  2076.    startup.el will try and deduce one.  If it fails, it knows how to
  2077.    handle things. */
  2078. #if 0
  2079.   /* Warn if dirs in the *standard* path don't exist.  */
  2080.   {
  2081.     Lisp_Object normal_path = decode_env_path (0, normal);
  2082.     for (; !NILP (normal_path); normal_path = XCDR (normal_path))
  2083.       {
  2084.         Lisp_Object dirfile;
  2085.         dirfile = Fcar (normal_path);
  2086.         if (!NILP (dirfile))
  2087.           {
  2088.         dirfile = Fdirectory_file_name (dirfile);
  2089.             if (access ((char *) string_data (XSTRING (dirfile)), 0) < 0)
  2090.               stdout_out ("Warning: lisp library (%s) does not exist.\n",
  2091.               string_data (XSTRING (Fcar (normal_path))));
  2092.           }
  2093.       }
  2094.   }
  2095. #endif /* 0 */
  2096. #else /* !PATH_LOADSEARCH */
  2097.   CONST char *normal = 0;
  2098. #endif /* !PATH_LOADSEARCH */
  2099.   Vvalues = Qnil;
  2100.  
  2101.   /* further frobbed by startup.el if nil. */
  2102.   Vload_path = decode_env_path ("EMACSLOADPATH", normal);
  2103.  
  2104. /*  Vdump_load_path = Qnil; */
  2105. #ifndef CANNOT_DUMP
  2106.   if (purify_flag && NILP (Vload_path))
  2107.     {
  2108.       /* loadup.el will frob this some more. */
  2109.       /* #### unix-specific */
  2110.       Vload_path = Fcons (build_string ("../lisp/prim"), Vload_path);
  2111.     }
  2112. #endif /* not CANNOT_DUMP */
  2113.   load_in_progress = 0;
  2114.  
  2115.   load_descriptor_list = Qnil;
  2116.  
  2117.   Vread_buffer_stream = make_resizing_buffer_stream ();
  2118. }
  2119.  
  2120. void
  2121. syms_of_lread (void)
  2122. {
  2123.   defsubr (&Sread);
  2124.   defsubr (&Sread_from_string);
  2125.   defsubr (&Sload_internal);
  2126.   defsubr (&Slocate_file);
  2127.   defsubr (&Slocate_file_clear_hashing);
  2128.   defsubr (&Seval_buffer);
  2129.   defsubr (&Seval_region);
  2130. #ifdef standalone
  2131.   defsubr (&Sread_char);
  2132. #endif
  2133.  
  2134.   defsymbol (&Qstandard_input, "standard-input");
  2135.   defsymbol (&Qread_char, "read-char");
  2136.   defsymbol (&Qcurrent_load_list, "current-load-list");
  2137.   defsymbol (&Qload, "load");
  2138.   defsymbol (&Qlocate_file_hash_table, "locate-file-hash-table");
  2139. }
  2140.  
  2141. void
  2142. vars_of_lread (void)
  2143. {
  2144.   DEFVAR_LISP ("values", &Vvalues,
  2145.     "List of values of all expressions which were read, evaluated and printed.\n\
  2146. Order is reverse chronological.");
  2147.  
  2148.   DEFVAR_LISP ("standard-input", &Vstandard_input,
  2149.     "Stream for read to get input from.\n\
  2150. See documentation of `read' for possible values.");
  2151.   Vstandard_input = Qt;
  2152.  
  2153.   DEFVAR_LISP ("load-path", &Vload_path,
  2154.     "*List of directories to search for files to load.\n\
  2155. Each element is a string (directory name) or nil (try default directory).\n\n\
  2156. Note that the elements of this list *may not* begin with \"~\", so you must\n\
  2157. call `expand-file-name' on them before adding them to this list.\n\n\
  2158. Initialized based on EMACSLOADPATH environment variable, if any,\n\
  2159. otherwise to default specified in by file `paths.h' when Emacs was built.\n\
  2160. If there were no paths specified in `paths.h', then emacs chooses a default\n\
  2161. value for this variable by looking around in the file-system near the\n\
  2162. directory in which the emacs executable resides.");
  2163.  
  2164. /*  xxxDEFVAR_LISP ("dump-load-path", &Vdump_load_path,
  2165.     "*Location of lisp files to be used when dumping ONLY."); */
  2166.  
  2167.   DEFVAR_BOOL ("load-in-progress", &load_in_progress,
  2168.     "Non-nil iff inside of `load'.");
  2169.  
  2170.   DEFVAR_LISP ("after-load-alist", &Vafter_load_alist,
  2171.     "An alist of expressions to be evalled when particular files are loaded.\n\
  2172. Each element looks like (FILENAME FORMS...).\n\
  2173. When `load' is run and the file-name argument is FILENAME,\n\
  2174. the FORMS in the corresponding element are executed at the end of loading.\n\n\
  2175. FILENAME must match exactly!  Normally FILENAME is the name of a library,\n\
  2176. with no directory specified, since that is how `load' is normally called.\n\
  2177. An error in FORMS does not undo the load,\n\
  2178. but does prevent execution of the rest of the FORMS.");
  2179.   Vafter_load_alist = Qnil;
  2180.  
  2181.   DEFVAR_BOOL ("load-warn-when-source-newer", &load_warn_when_source_newer,
  2182.   "*Whether `load' should check whether the source is newer than the binary;\n\
  2183. If this variable is true, then when a `.elc' file is being loaded and the\n\
  2184. corresponding `.el' is newer, a warning message will be printed.");
  2185.   load_warn_when_source_newer = 0;
  2186.  
  2187.   DEFVAR_BOOL ("load-warn-when-source-only", &load_warn_when_source_only,
  2188.   "*Whether `load' should warn when loading a .el file instead of an .elc.\n\
  2189. If this variable is true, then when load is called with a filename without\n\
  2190. an extension, and the .elc version doesn't exist but the .el version does,\n\
  2191. then a message will be printed.  If an explicit extension is passed to load,\n\
  2192. no warning will be printed.");
  2193.   load_warn_when_source_only = 0;
  2194.  
  2195.   DEFVAR_BOOL ("load-ignore-elc-files", &load_ignore_elc_files,
  2196.     "*Whether `load' should ignore `.elc' files when a suffix is not given.\n\
  2197. This is normally used only to bootstrap the .elc files when building Emacs.");
  2198.   load_ignore_elc_files = 0;
  2199.  
  2200. #ifdef LOADHIST
  2201.   DEFVAR_LISP ("load-history", &Vload_history,
  2202.     "Alist mapping source file names to symbols and features.\n\
  2203. Each alist element is a list that starts with a file name,\n\
  2204. except for one element (optional) that starts with nil and describes\n\
  2205. definitions evaluated from buffers not visiting files.\n\
  2206. The remaining elements of each list are symbols defined as functions\n\
  2207. or variables, and cons cells `(provide . FEATURE)' and `(require . FEATURE)'.");
  2208.   Vload_history = Qnil;
  2209.  
  2210.   DEFVAR_LISP ("current-load-list", &Vcurrent_load_list,
  2211.     "Used for internal purposes by `load'.");
  2212.   Vcurrent_load_list = Qnil;
  2213. #endif
  2214.  
  2215.   DEFVAR_BOOL ("fail-on-bucky-bit-character-escapes", &puke_on_fsf_keys,
  2216.     "Whether `read' should signal an error when it encounters unsupported\n\
  2217. character escape syntaxes or just read them incorrectly.");
  2218.   puke_on_fsf_keys = 0;
  2219.  
  2220.   /* This must be initialized in init_lread otherwise it may start out
  2221.      with values saved when the image is dumped. */
  2222.   staticpro (&load_descriptor_list);
  2223.  
  2224.   /* This gets initialized in init_lread because all streams get closed
  2225.      when dumping occurs */
  2226.   staticpro (&Vread_buffer_stream);
  2227.  
  2228.   /* So that early-early stuff will work */
  2229.   Ffset (Qload, intern ("load-internal"));
  2230.  
  2231. #ifdef LISP_BACKQUOTES
  2232.   Qbackquote = intern ("backquote");
  2233.   staticpro (&Qbackquote);
  2234.   Qbacktick = intern ("`");
  2235.   staticpro (&Qbacktick);
  2236.   Qcomma = intern (",");
  2237.   staticpro (&Qcomma);
  2238.   Qcomma_at = intern (",@");
  2239.   staticpro (&Qcomma_at);
  2240.   reading_old_backquote = reading_backquote = 0;
  2241. #endif
  2242.   
  2243. #ifdef I18N3
  2244.   Vfile_domain = Qnil;
  2245. #endif
  2246. }
  2247.